home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / dired-xemacs.el.z / dired-xemacs.el
Encoding:
Text File  |  1998-05-21  |  26.1 KB  |  755 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;; File:          dired-xemacs.el
  4. ;; Dired Version: #Revision: 7.9 $
  5. ;; RCS:
  6. ;; Description:   dired functions for XEmacs
  7. ;; Author:        Mike Sperber <sperber@informatik.uni-tuebingen.de>
  8. ;; 
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (provide 'dired-xemacs)
  12. (require 'dired)
  13. (require 'dired-faces)
  14.  
  15. (require 'backquote)
  16.  
  17.  
  18. ;;; Variables not meant for user editing
  19.  
  20. ;; kludge
  21. (defun dired-demarkify-regexp (re)
  22.   (if (string-equal (substring re 0 (length dired-re-maybe-mark))
  23.             dired-re-maybe-mark)
  24.       (concat "^" (substring re
  25.                  (length dired-re-maybe-mark)
  26.                  (length re)))
  27.     re))
  28.  
  29. (defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir))
  30. (defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym))
  31. (defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe))
  32.  
  33. (defvar dired-re-raw-boring (dired-omit-regexp)
  34.   "Regexp to match backup, autosave and otherwise boring files.")
  35.  
  36. (defvar dired-re-raw-socket (concat "^" dired-re-inode-size "s"))
  37.  
  38. (defvar dired-re-raw-setuid
  39.   (concat "^" dired-re-inode-size
  40.       "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]")
  41.   "setuid plain file (even if not executable)")
  42.  
  43. (defvar dired-re-raw-setgid 
  44.   (concat "^" dired-re-inode-size
  45.       "-[-r][-w][-x][-r][-w][sS][-r][-w][xst]")
  46.   "setgid plain file (even if not executable)")
  47.  
  48. (defvar dired-re-pre-permissions "^[^-d]? ?[0-9     ]*[-d]"
  49.   "Regexp matching the preamble to file permissions part of a dired line.
  50. This shouldn't match socket or symbolic link lines (which aren't editable).")
  51.  
  52. (defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-Ssx][-r][-w][-xstT]"
  53.   "Regexp matching the file permissions part of a dired line.")
  54.  
  55. ;;; Setup
  56.  
  57. (setq dired-modeline-tracking-cmds '(mouse-track))
  58.  
  59.  
  60. ;;; Menus
  61.  
  62. (defvar dired-subdir-menu nil "The Subdir menu for dired")
  63. (defvar dired-mark-menu nil "The Mark menu for dired")
  64. (defvar dired-do-menu nil "The Do menu for dired")
  65. (defvar dired-regexp-menu nil "The Regexp menu for dired")
  66. (defvar dired-look-menu nil "The Look menu for dired")
  67. (defvar dired-sort-menu nil "The Sort menu for dired")
  68. (defvar dired-help-menu nil "The Help menu for dired")
  69.  
  70. (defvar dired-menubar-menus
  71.   '(("Subdir" . dired-subdir-menu)
  72.     ("Mark" . dired-mark-menu)
  73.     ("Do" . dired-do-menu)
  74.     ("Regexp" . dired-regexp-menu)
  75.     ("Look" . dired-look-menu)
  76.     ("Sort" . dired-sort-menu))
  77.   "All the dired menus.")
  78.  
  79. (defvar dired-visit-popup-menu nil "The Visit popup for dired")
  80. (defvar dired-do-popup-menu nil "The Do popup for dired")
  81.  
  82. (defun dired-setup-menus ()
  83.   (setq
  84.    dired-visit-popup-menu
  85.    '(["Find File" dired-find-file t]
  86.      ["Find in Other Window" dired-find-file-other-window t]
  87.      ["Find in Other Frame" dired-find-file-other-frame t]
  88.      ["View File" dired-view-file t]
  89.      ["Display in Other Window" dired-display-file t]))
  90.  
  91.   (setq
  92.    dired-do-popup-menu
  93.    '(["Copy to..." dired-do-copy t]
  94.      ["Rename to..." dired-do-rename t]
  95.      ["Compress/Uncompress" dired-do-compress t]
  96.      ["Uuencode/Uudecode" dired-do-uucode t]
  97.      ["Change Mode..." dired-do-chmod t]
  98.      ["Change Owner..." dired-do-chown t]
  99.      ["Change Group..." dired-do-chgrp t]
  100.      ["Load" dired-do-load t]
  101.      ["Byte-compile" dired-do-byte-compile t]
  102.      ["Hardlink to..." dired-do-hardlink t]
  103.      ["Symlink to..." dired-do-symlink t]
  104.      ["Shell Command..." dired-do-shell-command t]
  105.      ["Background Shell Command..." dired-do-background-shell-command t]
  106.      ["Delete" dired-do-delete t]))
  107.  
  108.   (setq
  109.    dired-subdir-menu
  110.    (list 
  111.     ["Next Subdir" dired-next-subdir t]
  112.     ["Prev Subdir" dired-prev-subdir t]
  113.     ["Next Dirline" dired-next-dirline t]
  114.     ["Prev Dirline" dired-prev-dirline t]
  115.     ["Up Dir" dired-up-directory t]
  116.     ["Down Dir" dired-down-directory t]
  117.     ["Insert This Subdir" dired-maybe-insert-subdir t]
  118.     ["Create Directory..." dired-create-directory t]
  119.     ["Kill This Subdir" dired-kill-subdir t]
  120.     "-- Commands on All Files in Subdir --"
  121.     ["Redisplay Subdir" dired-redisplay-subdir t]
  122.     ["Mark Files" dired-mark-subdir-files t]
  123.     ["Flag Files for Deletion" dired-flag-subdir-files t]
  124.     ["Compress Uncompressed Files" dired-compress-subdir-files t]
  125.     (vector "Uncompress Compressed Files"
  126.         '(let ((current-prefix-arg t))
  127.            (dired-compress-subdir-files))
  128.         ':keys (dired-key-description 'dired-compress-subdir-files
  129.                       'universal-argument))))
  130.  
  131.   (setq
  132.    dired-mark-menu
  133.    (list
  134.     ["Next Marked" dired-next-marked-file t]
  135.     ["Previous Marked" dired-prev-marked-file t]
  136.     ["Change Marks..." dired-change-marks t]
  137.     ["Unmark All" dired-unmark-all-files t]
  138.     (vector "Toggle marks..."
  139.         '(let ((current-prefix-arg t))
  140.            (call-interactively 'dired-change-marks))
  141.         ':keys (dired-key-description 'dired-change-marks
  142.                       'universal-argument))
  143.     ["Mark Symlinks" dired-mark-symlinks t]
  144.     ["Mark Directories" dired-mark-directories t]
  145.     ["Mark Old Backups" dired-clean-directory t]
  146.     ["Mark Executables" dired-mark-executables t]
  147.     ["Flag Backup Files" dired-flag-backup-files t]
  148.     ["Flag Auto-save Files" dired-flag-auto-save-files t]
  149.     ["Set new marker char" dired-set-marker-char t]
  150.     ["Restore marker char" dired-restore-marker-char t]
  151.     ["Marker stack left" dired-marker-stack-left t]
  152.     ["Marker stack right" dired-marker-stack-right t]
  153.     "---"
  154.     ["Mark Files from Other Dired" dired-mark-files-from-other-dired-buffer t]
  155.     ["Mark Files from Compile Buffer..." dired-mark-files-compilation-buffer t]))
  156.  
  157.    (setq
  158.    dired-do-menu
  159.    '(["Copy to..." dired-do-copy t]
  160.      ["Rename to..." dired-do-rename t]
  161.      ["Expunge File Flagged for Deletion" dired-expunge-deletions t]
  162.      ["Compress/Uncompress" dired-do-compress t]
  163.      ["Uuencode/Uudecode" dired-do-uucode t]
  164.      ["Print..." dired-do-print t]
  165.      ["Change Mode..." dired-do-interactive-chmod t]
  166.      ["Change Owner..." dired-do-chown t]
  167.      ["Change Group..." dired-do-chgrp t]
  168.      ["Load" dired-do-load t]
  169.      ["Byte-compile" dired-do-byte-compile t]
  170.      ["Hardlink to..." dired-do-hardlink t]
  171.      ["Symlink to..." dired-do-symlink t]
  172.      ["Shell Command..." dired-do-shell-command t]
  173.      ["Background Shell Command..." dired-do-background-shell-command t]
  174.      ["Delete Marked Files" dired-do-delete t]
  175.      ["Visit file menu >" dired-visit-popup-menu-internal t]
  176.      ["Operate on file menu >" dired-do-popup-menu-internal t]))
  177.  
  178.   (setq
  179.    dired-regexp-menu
  180.    (list
  181.     ["Mark..." dired-mark-files-regexp t]
  182.     ["Mark Files with Extension..." dired-mark-extension t]
  183.     ["Flag..." dired-flag-files-regexp t]
  184.     ["Flag Files with Extension..." dired-flag-extension t]
  185.     ["Downcase" dired-downcase t]
  186.     ["Upcase" dired-upcase t]
  187.     ["Copy..." dired-do-copy-regexp t]
  188.     ["Rename..." dired-do-rename-regexp t]
  189.     ["Hardlink..." dired-do-hardlink-regexp t]
  190.     ["Symlink..." dired-do-symlink-regexp t]
  191.     ["Relative Symlink..." dired-do-relsymlink-regexp t]
  192.     "---"
  193.     ["Add Omit Regex..." dired-add-omit-regexp t]
  194.     (vector "Remove Omit Regex..."
  195.         '(let ((current-prefix-arg 1))
  196.            (call-interactively 'dired-add-omit-regexp))
  197.         ':keys (dired-key-description 'dired-add-omit-regexp 1))
  198.     (vector "Add Omit Extension..."
  199.         '(let ((current-prefix-arg '(4)))
  200.            (call-interactively 'dired-add-omit-regexp))
  201.         ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument))
  202.     (vector "Remove Omit Extension..."
  203.         '(let ((current-prefix-arg '(16)))
  204.            (call-interactively 'dired-add-omit-regexp))
  205.         ':keys (dired-key-description 'dired-add-omit-regexp
  206.                       'universal-argument 'universal-argument))
  207.     (vector "Show Omit Regex"
  208.         '(let ((current-prefix-arg 0))
  209.            (call-interactively 'dired-add-omit-regexp))
  210.         ':keys (dired-key-description 'dired-add-omit-regexp 0))))
  211.  
  212.   (setq
  213.    dired-look-menu
  214.    '(["Grep for..." dired-do-grep t]
  215.      ["Tags Search for..." dired-do-tags-search t]
  216.      ["Tags Query Replace..." dired-do-tags-query-replace t]
  217.      "---"
  218.      ["Diff File..." dired-diff t]
  219.      ["Diff with Backup" dired-backup-diff t]
  220.      ["Merge Files..." dired-emerge t]
  221.      ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t]
  222.      ["Ediff Files..." dired-ediff t]
  223.      ["Patch File" dired-epatch t]))
  224.  
  225.   (setq
  226.    dired-sort-menu
  227.    (list
  228.     ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t]
  229.     (vector "Show Current Switches"
  230.         '(dired-sort-toggle-or-edit 0)
  231.         ':keys (dired-key-description 'dired-sort-toggle-or-edit 0))
  232.     (vector "Edit Switches for Current Subdir..."
  233.         '(dired-sort-toggle-or-edit 1)
  234.         ':keys (dired-key-description 'dired-sort-toggle-or-edit 1))
  235.     (vector "Edit Default Switches for Inserted Subdirs..."
  236.         '(dired-sort-toggle-or-edit 2) 
  237.         ':keys (dired-key-description 'dired-sort-toggle-or-edit 2))
  238.     (vector "Sort Entire Buffer by Date"
  239.         '(dired-sort-toggle-or-edit 'date)
  240.         ':keys (dired-key-description 'dired-sort-toggle-or-edit
  241.                       'universal-argument))
  242.     (vector "Sort Entire Buffer by Name"
  243.         '(dired-sort-toggle-or-edit 'name)
  244.         ':keys (dired-key-description 'dired-sort-toggle-or-edit
  245.                       'universal-argument))
  246.     (vector "Edit Switches for Entire Buffer..."
  247.         '(dired-sort-toggle-or-edit '(16))
  248.         ':keys (dired-key-description 'dired-sort-toggle-or-edit
  249.                       'universal-argument))
  250.     "---"
  251.     ["Hide All Subdirs" dired-hide-all t]
  252.     ["Hide Subdir" dired-hide-subdir t]
  253.     ["Toggle Omit" dired-omit-toggle t]
  254.     ["Kill Marked Lines" dired-do-kill-file-lines t]
  255.     (vector "Redisplay Killed Lines"
  256.         '(dired-do-kill-file-lines 0)
  257.         ':keys (dired-key-description 'dired-do-kill-file-lines "0"))))
  258.   (setq
  259.    dired-help-menu
  260.    (list
  261.     ["Dired Summary Help" dired-summary t]
  262.     ["Describe Dired" dired-describe-mode t]
  263.     (vector "Dired Info Manual"
  264.         '(dired-describe-mode t)
  265.         ':keys (dired-key-description 'dired-describe-mode
  266.                       'universal-argument))
  267.     ["Dired Command Apropos" dired-apropos t]
  268.     (vector "Dired Variable Apropos"
  269.         '(let ((current-prefix-arg t))
  270.            (call-interactively 'dired-apropos))
  271.         ':keys (dired-key-description 'dired-apropos 'universal-argument))
  272.     ["Report Dired Bug" dired-report-bug t])))
  273.  
  274. (defun dired-install-menubar ()
  275.   "Installs the Dired menu at the menubar."
  276.   (if (null dired-help-menu)
  277.       (dired-setup-menus))
  278.   (if (and (featurep 'menubar) current-menubar)
  279.       (progn
  280.     (let ((buffer-menubar (copy-sequence current-menubar)))
  281.       (set-buffer-menubar buffer-menubar)
  282.       (mapcar
  283.        (function
  284.         (lambda (pair)
  285.           (let ((name (car pair))
  286.             (menu (symbol-value (cdr pair))))
  287.         (add-submenu nil (cons name menu)))))
  288.        dired-menubar-menus))
  289.     (add-menu-button '("Help") (list "---"))
  290.     (add-submenu '("Help") (cons "Dired" dired-help-menu)))))
  291.  
  292. (add-hook 'dired-mode-hook 'dired-install-menubar)
  293.  
  294. ;;; Mouse functions
  295.  
  296. (defun dired-mouse-file-action (event fun)
  297.   "In dired, apply function FUN to the file or directory name you click on."
  298.   (save-excursion
  299.     (set-buffer (window-buffer (event-window event)))
  300.     (if dired-subdir-alist
  301.     (save-excursion
  302.       (goto-char (event-point event))
  303.       (funcall fun))
  304.       (error
  305.        (concat "dired-subdir-alist seems to be mangled.  "
  306.            (substitute-command-keys
  307.         "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
  308.  
  309. (defun dired-mouse-find-file (event)
  310.   "In dired, visit the file or directory name you click on."
  311.   (interactive "e")
  312.   (dired-mouse-file-action event 'dired-find-file))
  313.  
  314. (defun dired-mouse-display-file (event)
  315.   "In dired, display the file or directory name you click on."
  316.   (interactive "e")
  317.   (dired-mouse-file-action event 'dired-display-file))
  318.  
  319. (defun dired-mouse-find-file-other-window (event)
  320.   "In dired, visit the file or directory name you click on in another window."
  321.   (interactive "e")
  322.   (dired-mouse-file-action event 'dired-find-file-other-window))
  323.  
  324. (defun dired-mouse-find-file-other-frame (event)
  325.   "In dired, visit the file or directory name you click on in another frame."
  326.   (interactive "e")
  327.   (dired-mouse-file-action event 'dired-find-file-other-frame))
  328.  
  329. (defun dired-mouse-mark (event)
  330.   "In dired, mark the file name that you click on.
  331. If the file name is already marked, this unmarks it."
  332.   (interactive "e")
  333.   (save-excursion
  334.     (set-buffer (window-buffer (event-window event)))
  335.     (if dired-subdir-alist
  336.     (save-excursion
  337.       (goto-char (event-point event))
  338.       (beginning-of-line)
  339.       (if (looking-at dired-re-mark)
  340.           (dired-unmark 1)
  341.         (dired-mark 1)))
  342.       (error
  343.        (concat "dired-subdir-alist seems to be mangled.  "
  344.            (substitute-command-keys
  345.         "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
  346.  
  347. (defun dired-mouse-flag (event)
  348.   "In dired, flag for deletion the file name that you click on.
  349. If the file name is already flag, this unflags it."
  350.   (interactive "e")
  351.   (save-excursion
  352.     (set-buffer (window-buffer (event-window event)))
  353.     (if dired-subdir-alist
  354.     (save-excursion
  355.       (goto-char (event-point event))
  356.       (beginning-of-line)
  357.       (if (char-equal (char-after (point)) dired-del-marker)
  358.           (dired-unflag 1)
  359.         (dired-flag-file-deletion 1)))
  360.       (error
  361.        (concat "dired-subdir-alist seems to be mangled.  "
  362.            (substitute-command-keys
  363.         "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
  364.  
  365. (defun dired-mouse-get-target (event)
  366.   "In dired, put a copy of the selected directory in the active minibuffer."
  367.   (interactive "e")
  368.   (let ((obuff (current-buffer))
  369.     mb)
  370.     (set-buffer (window-buffer (event-window event)))
  371.     (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window)))
  372.     (let (dir)
  373.       (goto-char (event-point event))
  374.       (setq dir (dired-current-directory))
  375.       (select-window mb)
  376.       (set-buffer (window-buffer mb))
  377.       (erase-buffer)
  378.       (insert dir))
  379.       (set-buffer obuff)
  380.       (if mb
  381.       (error "No directory specified")
  382.     (error "No active minibuffer")))))
  383.  
  384. (defun dired-visit-popup-menu (event)
  385.   "Popup a menu to visit the moused file."
  386.   (interactive "e")
  387.   (save-excursion
  388.     (set-buffer (window-buffer (event-window event)))
  389.     (save-excursion
  390.       (goto-char (event-point event))
  391.       (dired-visit-popup-menu-internal event))))
  392.  
  393. (defun dired-visit-popup-menu-internal (event)
  394.   (interactive "e")
  395.   (let ((fn (dired-get-filename 'no-dir)))
  396.     (popup-menu
  397.      (cons (concat "Visit " fn " with") dired-visit-popup-menu))
  398.     ;; this looks like a kludge to me ...
  399.     (while (popup-up-p)
  400.       (dispatch-event (next-event)))))
  401.  
  402. (defun dired-do-popup-menu (event)
  403.   "Pop up a menu to do an operation on the moused file."
  404.   (interactive "e")
  405.   (let ((obuff (current-buffer)))
  406.     (unwind-protect
  407.     (progn
  408.       (set-buffer (window-buffer (event-window event)))
  409.       (dired-save-excursion
  410.         (goto-char (event-point event))
  411.         (dired-do-popup-menu-internal event)))
  412.       (set-buffer obuff))))
  413.  
  414. (defun dired-do-popup-menu-internal (event)
  415.   (interactive "e")
  416.   (let ((fn (dired-get-filename 'no-dir))
  417.     (current-prefix-arg 1))
  418.     (popup-menu
  419.      (cons (concat "Do operation on " fn) dired-do-popup-menu))
  420.     (while (popup-up-p)
  421.       (dispatch-event (next-event)))))
  422.  
  423. (defvar dired-filename-local-map
  424.   (let ((map (make-sparse-keymap)))
  425.     (set-keymap-name map 'dired-filename-local-map)
  426.     (define-key map [button2]           'dired-mouse-find-file)
  427.     (define-key map [(shift button2)]   'dired-mouse-display-file)
  428.     (define-key map [(meta button2)]    'dired-mouse-find-file-other-frame)
  429.     (define-key map [button3]           'dired-visit-popup-menu)
  430.     (define-key map [(control button2)] 'dired-do-popup-menu)
  431.     (define-key map [(shift button1)]   'dired-mouse-mark)
  432.     (define-key map [(control shift button1)] 'dired-mouse-flag)
  433.     map)
  434.   "Keymap used to activate actions on files in dired.")
  435.  
  436. ;; Make this defined everywhere in the dired buffer.
  437. (define-key dired-mode-map '(meta button3) 'dired-mouse-get-target)
  438.  
  439. ;;; Extent managment
  440.  
  441. (defun dired-set-text-properties (start end &optional face)
  442.   (let ((filename-extent (make-extent start end)))
  443.     (set-extent-face filename-extent (or face 'default))
  444.     (set-extent-property filename-extent 'dired-file-name t)
  445.     (set-extent-property filename-extent 'start-open t)
  446.     (set-extent-property filename-extent 'end-open t)
  447.     (set-extent-property filename-extent 'keymap dired-filename-local-map)
  448.     (set-extent-property filename-extent 'highlight t)
  449.     (set-extent-property
  450.      filename-extent 'help-echo
  451.      (concat
  452.       "button2 finds, button3 visits, "
  453.       "C-button2 file ops, [C-]shift-button1 marks/flags."))
  454.     filename-extent))
  455.  
  456. (defun dired-insert-set-properties (beg end)
  457.   ;; Sets the extents for the file names and their properties
  458.   (save-excursion
  459.     (goto-char beg)
  460.     (beginning-of-line)
  461.     (let ((eol (save-excursion (end-of-line) (point)))
  462.           (bol (point))
  463.           start)
  464.       (while (< (point) end)
  465.         (setq eol (save-excursion (end-of-line) (point))) 
  466.  
  467.     (if dired-do-interactive-permissions
  468.         (dired-make-permissions-interactive (point)))
  469.  
  470.         (if (dired-manual-move-to-filename nil bol eol)
  471.             (progn
  472.               (setq start (point))
  473.               (dired-manual-move-to-end-of-filename nil bol eol)
  474.           (dired-set-text-properties
  475.            start
  476.            (point)
  477.            (save-excursion
  478.          (beginning-of-line)
  479.          (cond
  480.           ((null dired-do-highlighting) nil)
  481.           ((looking-at dired-re-raw-dir) 'dired-face-directory)
  482.           ((looking-at dired-re-raw-sym) 'dired-face-symlink)
  483.           ((or (looking-at dired-re-raw-setuid)
  484.                (looking-at dired-re-raw-setgid)) 'dired-face-setuid)
  485.           ((looking-at dired-re-raw-exe) 'dired-face-executable)
  486.           ((looking-at dired-re-raw-socket) 'dired-face-socket)
  487.           ((save-excursion
  488.              (goto-char start)
  489.              (save-restriction
  490.                (narrow-to-region (point) eol)
  491.                (re-search-forward dired-re-raw-boring eol t)))
  492.            'dired-face-boring))))))
  493.  
  494.         (setq bol (1+ eol))
  495.         (goto-char bol)))))
  496.  
  497. (defun dired-remove-text-properties (start end)
  498.   ;; Removes text properties.  Called in popup buffers.
  499.   (map-extents
  500.    (function
  501.     (lambda (extent maparg)
  502.       (if (extent-property extent 'dired-file-name)
  503.       (delete-extent extent))
  504.       nil))
  505.    nil start end))
  506.  
  507. (defun dired-highlight-filename-mark (extent)
  508.   (let ((mark
  509.      (save-excursion
  510.        (skip-chars-backward "^\n\r")
  511.        (char-after (point))))
  512.     (face (extent-face extent)))
  513.     (if (char-equal mark ?\ )
  514.     (if (consp face)
  515.         (set-extent-face extent (cadr face)))
  516.       (let ((new-face
  517.          (cond
  518.           ((char-equal dired-default-marker mark)
  519.            'dired-face-marked)
  520.           ((char-equal dired-del-marker mark)
  521.            'dired-face-flagged)
  522.           (t 'default))))
  523.     (set-extent-face
  524.      extent
  525.      (if (consp face)
  526.          (list new-face (cadr face))
  527.        (list new-face face)))))))
  528.  
  529. (defun dired-move-to-filename (&optional raise-error bol eol)
  530.   (or bol (setq bol (save-excursion
  531.               (skip-chars-backward "^\n\r")
  532.               (point))))
  533.   (or eol (setq eol (save-excursion
  534.               (skip-chars-forward "^\n\r")
  535.               (point))))
  536.   (goto-char bol)
  537.   (let ((extent
  538.      (map-extents
  539.       (function
  540.        (lambda (extent maparg)
  541.          (if (extent-property extent 'dired-file-name)
  542.          extent
  543.            nil)))
  544.       nil bol eol)))
  545.     (if extent
  546.     (progn
  547.       (if dired-do-highlighting
  548.           (dired-highlight-filename-mark extent))
  549.       (goto-char (extent-start-position extent)))
  550.       (if raise-error
  551.       (error "No file on this line")
  552.     nil))))
  553.  
  554.  
  555. (defun dired-move-to-end-of-filename (&optional no-error bol eol)
  556.   ;; Assumes point is at beginning of filename,
  557.   ;; thus the rwx bit re-search-backward below will succeed in *this*
  558.   ;; line if at all.  So, it should be called only after
  559.   ;; (dired-move-to-filename t).
  560.   ;; On failure, signals an error (with non-nil NO-ERROR just returns nil).
  561.   (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point))))
  562.   (and
  563.    (null no-error)
  564.    selective-display
  565.    (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point))))
  566.    (eq (char-after (1- bol)) ?\r)
  567.    (cond
  568.     ((dired-subdir-hidden-p (dired-current-directory))
  569.      (error
  570.       (substitute-command-keys
  571.        "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
  572.     ((error
  573.       (substitute-command-keys
  574.        "File line is omitted. Type \\[dired-omit-toggle] to un-omit.")))))
  575.   (let ((filename-extent  (map-extents
  576.                  (function
  577.                   (lambda (e p) (and (extent-property e p) e)))
  578.                  (current-buffer) bol eol 'dired-file-name)))
  579.     (if filename-extent
  580.     (goto-char (extent-end-position filename-extent))
  581.       (and (null no-error) (error "No file on this line")))))
  582.  
  583. ;;; Interactive chmod
  584. ;;; (based on ideas from Russell Ritchie's dired-chmod.el)
  585.  
  586. (defun dired-do-interactive-chmod (new-attribute)
  587.   (let* ((file (dired-get-filename))
  588.      (operation (concat "chmod " new-attribute " " file))
  589.      (failure (apply (function dired-check-process)
  590.              operation
  591.              "chmod" new-attribute (list file))))
  592.     (dired-do-redisplay)
  593.     (if failure
  594.     (dired-log-summary (buffer-name (current-buffer))
  595.                (format "%s: error" operation) nil)
  596.       (forward-char 1))))
  597.  
  598. (defun dired-chmod-popup-menu (event menu)
  599.   (save-excursion
  600.     (set-buffer (window-buffer (event-window event)))
  601.     (save-excursion
  602.       (goto-char (event-point event))
  603.       (popup-menu menu)
  604.       ;; this looks like a kludge to me ...
  605.       (while (popup-up-p)
  606.     (dispatch-event (next-event))))))
  607.  
  608. ;; This is probably overdoing it.
  609. ;; Someone give me lexical scoping here ...
  610.  
  611. (defun dired-setup-chmod-keymap (domain id keys &optional toggle-keys)
  612.   (let* ((names
  613.       (mapcar
  614.        (function
  615.         (lambda (key)
  616.           (let ((name (intern (concat "dired-"
  617.                       (list domain ?-  key)))))
  618.         (eval
  619.          `(defun ,name ()
  620.             (interactive)
  621.             (dired-do-interactive-chmod ,(concat (list domain ?+ key)))))
  622.         name)))
  623.        keys))
  624.      (prefix (concat "dired-" (list domain) "-" (list id)))
  625.      (remove-name (intern (concat prefix "-remove")))
  626.      (toggle-name (intern (concat prefix "-toggle")))
  627.      (mouse-toggle-name (intern (concat prefix "-mouse-toggle")))
  628.      (mouse-menu-name (intern (concat prefix "-menu"))))
  629.  
  630.     (eval
  631.      `(defun ,remove-name ()
  632.     (interactive)
  633.     (cond ,@(mapcar (function
  634.              (lambda (key)
  635.                `((looking-at ,(regexp-quote (char-to-string key)))
  636.                  (dired-do-interactive-chmod
  637.                   ,(concat (list domain ?- key))))))
  638.             keys))))
  639.  
  640.     (eval
  641.      `(defun ,toggle-name ()
  642.     (interactive)
  643.     (cond ((looking-at "-") (dired-do-interactive-chmod
  644.                  ,(concat (list domain ?+ (car keys)))))
  645.           ,@(let ((l (or toggle-keys keys))
  646.               (c '()))
  647.           (while l
  648.             (setq c
  649.               (cons
  650.                `((looking-at (regexp-quote (char-to-string ,(car l))))
  651.                  (dired-do-interactive-chmod
  652.                   ,(if (null (cdr l))
  653.                    (concat (list domain ?- (car l)))
  654.                  (concat (list domain ?+ (cadr l))))))
  655.                c))
  656.             (setq l (cdr l)))
  657.           (reverse c))
  658.           (t (dired-do-interactive-chmod
  659.           ,(concat (list domain ?+ (car keys))))))))
  660.  
  661.     (eval
  662.      `(defun ,mouse-toggle-name (event)
  663.     (interactive "e")
  664.     (save-excursion
  665.       (set-buffer (window-buffer (event-window event)))
  666.       (save-excursion
  667.         (goto-char (event-point event))
  668.         (,toggle-name)))))
  669.  
  670.     (let ((menu '())
  671.       (loop-keys keys)
  672.       (loop-names names))
  673.       (while loop-keys
  674.     (setq menu
  675.           (cons (vector (concat (list ?+ (car loop-keys)))
  676.                 (car loop-names)
  677.                 t)
  678.             menu))
  679.     (setq loop-keys (cdr loop-keys)
  680.           loop-names (cdr loop-names)))
  681.       (setq menu (append menu (list (vector "Toggle" toggle-name t)
  682.                     (vector "Clear" remove-name t))))
  683.       (setq menu (cons (char-to-string domain) menu))
  684.  
  685.       (eval
  686.        `(defun ,mouse-menu-name (event)
  687.       (interactive "e")
  688.       (dired-chmod-popup-menu event ',menu))))
  689.  
  690.     (let ((keymap (make-sparse-keymap)))
  691.       (let ((loop-keys (cons ?. (cons ?- keys)))
  692.         (loop-names (cons toggle-name (cons remove-name names))))
  693.     (while loop-keys
  694.       (define-key keymap (car loop-keys) (car loop-names))
  695.       (setq loop-keys (cdr loop-keys)
  696.         loop-names (cdr loop-names))))
  697.  
  698.       (define-key keymap 'button2 mouse-toggle-name)
  699.       (define-key keymap 'button3 mouse-menu-name)
  700.       keymap)))
  701.     
  702. (defvar dired-u-r-keymap nil "internal keymap for dired")
  703. (defvar dired-u-w-keymap nil "internal keymap for dired")
  704. (defvar dired-u-x-keymap nil "internal keymap for dired")
  705. (defvar dired-g-r-keymap nil "internal keymap for dired")
  706. (defvar dired-g-w-keymap nil "internal keymap for dired")
  707. (defvar dired-g-x-keymap nil "internal keymap for dired")
  708. (defvar dired-o-r-keymap nil "internal keymap for dired")
  709. (defvar dired-o-w-keymap nil "internal keymap for dired")
  710. (defvar dired-o-x-keymap nil "internal keymap for dired")
  711.  
  712.  
  713. (defun dired-setup-chmod-keymaps ()
  714.   (setq
  715.    dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r))
  716.    dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w))
  717.    dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?x ?s) '(?x))
  718.    dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r))
  719.    dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w))
  720.    dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?x ?s) '(?x))
  721.    dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r))
  722.    dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w))
  723.    dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?x ?s ?t) '(?x))))
  724.  
  725. (defun dired-make-permissions-interactive (beg)
  726.   (save-excursion
  727.     (goto-char beg)
  728.     (buffer-substring (point) (save-excursion (end-of-line) (point)))
  729.     (if (and (re-search-forward dired-re-pre-permissions
  730.                 (save-excursion (end-of-line) (point))
  731.                 t)
  732.          (looking-at dired-re-permissions))
  733.     (let ((p (point)))
  734.       (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap)
  735.       (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap)
  736.       (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap)
  737.       (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap)
  738.       (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap)
  739.       (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap)
  740.       (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap)
  741.       (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap)
  742.       (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap)))))
  743.  
  744. (defun dired-activate-permissions (extent keymap)
  745.   (set-extent-face extent 'dired-face-permissions)
  746.   (set-extent-property extent 'keymap keymap)
  747.   (set-extent-property extent 'highlight t)
  748.   (set-extent-property
  749.    extent 'help-echo
  750.    "button2 toggles, button3 changes otherwise."))
  751.  
  752. (dired-setup-chmod-keymaps)
  753.       
  754. ;;; end of dired-xemacs.el
  755.